;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the 3600 version of the file portable-low.
;;;

(in-package 'pcl)

(defmacro without-interrupts (&body body)
  `(zl:without-interrupts ,.body))

  ;;   
;;;;;; Load Time Constants
  ;;
;;;
;;; This implementation of load-time-eval exploits the perhaps questionable
;;; feature that it is possible to define optimizers on macros.
;;; 
;;;   WHEN                       EXPANDS-TO
;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
;;;   compile to core            '<result of evaluating form>
;;;   not in compiler at all     (progn <form>)
;;;
(defmacro load-time-eval (form)
  ;; The interpreted definition of load-time-eval.  This definition
  ;; never gets compiled.
  (let ((value (gensym)))
    `(multiple-value-bind (,value)
	 (progn ,form)
       ,value)))

(compiler:defoptimizer (load-time-eval compile-load-time-eval)
		       (form)
  ;; When compiling a call to load-time-eval the compiler will call
  ;; this optimizer before the macro expansion.  The check to see
  ;; if we are really inside the compiler is probably wild overkill...
  (if (not zl:compiler:(AND (BOUNDP 'QC-FILE-IN-PROGRESS)
			    QC-FILE-IN-PROGRESS))
      form
      (if zl:compiler:(and (boundp '*compile-function*)	;Probably don't need
						        ;this boundp check
						        ;but it can't hurt.
			   (funcall *compile-function* :to-core-p))
	  ;; Compiling to core.
	  ;; Evaluate the form now, and expand into a constant
	  ;; (the result of evaluating the form).
	  `',(eval (cadr form))
	  ;; Compiling to a file.
	  ;; Generate the magic which causes the dumper compiler and loader
	  ;; to do magic and evaluate the form at load time.
	  `',(cons zl:compiler:eval-at-load-time-marker (cadr form)))))

  ;;   
;;;;;; Memory Block primitives.
  ;;   


(defmacro make-memory-block (size &optional area)
  `(make-array ,size :area ,area))

(defmacro memory-block-ref (block offset)	;Don't want to go faster yet.
  `(aref ,block ,offset))

(defvar class-wrapper-area)
(eval-when (load eval)
  (si:make-area :name 'class-wrapper-area
		:room t
		:gc :static))


;;;
;;; Reimplementation OF %INSTANCE
;;;
;;; We take advantage of the fact that Symbolics defstruct doesn't depend on
;;; the fact that Common Lisp defstructs are fixed length.  This allows us to
;;; use defstruct to define a new type, but use internal structure allocation
;;; code to make structure of that type of any length we like.
;;;
;;; In Symbolics Common Lisp, structures are really just arrays with a magic
;;; bit set.  The first element of the array points to the symbol which is
;;; the name of this structure.  The remaining elements are used for the
;;; slots of the structure.
;;;
;;; In our %instance datatype, the array look like
;;;
;;;  element 0:  The symbol %INSTANCE, this tells the system what kind of
;;;              structure this is.
;;;  element 1:  The meta-class of this %INSTANCE
;;;  element 2:  This is used to store the value of %instance-ref slot 0.
;;;  element 3:  This is used to store the value of %instance-ref slot 1.
;;;     .                                .
;;;     .                                .
;;;
(defstruct (%instance (:print-function print-instance)
		      (:constructor nil)
		      (:predicate %instancep))
  meta-class)

(zl:defselect ((:property %instance zl:named-structure-invoke))
  (:print-self (iwmc-class stream print-depth *print-escape*)
	       (print-instance iwmc-class stream print-depth))
  (:describe   (iwmc-class &optional no-complaints)
	       (ignore no-complaints)
	       (describe-instance iwmc-class)))

(defmacro %make-instance (meta-class size)
  (let ((instance-var (gensym)))
    `(let ((,instance-var (make-array (+ 2 ,size))))
       (setf (SI:ARRAY-NAMED-STRUCTURE-BIT ,instance-var) 1
	     (aref ,instance-var 0) '%instance
	     (aref ,instance-var 1) ,meta-class)
       ,instance-var)))

(defmacro %instance-ref (instance index)
  `(aref ,instance (+ ,index 2)))

  ;;   
;;;;;; Cache No's
  ;;  

(zl:defsubst symbol-cache-no (symbol mask)
  (logand (si:%pointer symbol) mask))		    

(compiler:defoptimizer (symbol-cache-no fold-symbol-cache-no) (form)
  (if (and (constantp (cadr form))		                    
	   (constantp (caddr form)))		                    
      `(load-time-eval ,(logand (si:%pointer (cadr form)) (caddr form)))
      form))

(defmacro object-cache-no (object mask)
  `(logand (si:%pointer ,object) ,mask))

  ;;   
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (si:%pointer thing)))

  ;;   
;;;;;; function-arglist
  ;;
;;;
;;; This is hard, I am sweating.
;;; 
(defun function-arglist (function) (zl:arglist function t))

(defun function-pretty-arglist (function) (zl:arglist function))

;; Unfortunately, this doesn't really work...
(defun set-function-pretty-arglist (function new-value)
  (ignore function new-value))

;; But this does...
(zl:advise zl:arglist
	   :after
	   pcl-patch-to-arglist
	   ()
  (let ((function (car zl:arglist))
	(discriminator nil))
      (when (and (symbolp function)
		 (setq discriminator (discriminator-named function)))
	(setq values (list (discriminator-pretty-arglist discriminator))))))


  ;;   
;;;;;; 
  ;;   

(defun record-definition (name type &optional parent-name parent-type)
  parent-name parent-type ;ignore
  (when (eq parent-type 'defmeth) (compiler:function-defined name))
  (si:record-source-file-name name type t)  
  ;; Can't really do the function parent stuff right all that easily,
  ;; and that is sort of a drag.  Zetalisp takes a different position
  ;; about source-file-name info and function-parent info.  I think the
  ;; function parent position is probably more correct, but unfortunately
  ;; requires that the function be defined first.  Maybe PCL needs a
  ;; defun-with-parent macro which could save it.
  t)

(defun compile-time-define (type name &rest ignore)
  (case type
    (defun (compiler:file-declare name 'zl:def 'zl:ignore))))

  ;;   
;;;;;; Environment support and Bug-Fixes
  ;;
;;; Some VERY basic environment support for the 3600, and some bug fixes and
;;; improvements to 3600 system utilities.  These may need some work before
;;; they will work in release 7.
;;; 
(eval-when (load eval)
  (setf
    (get 'defmeth 'zwei:definition-function-spec-type) 'defun
   ;(get 'defmeth 'zwei:definition-function-spec-finder-template) '(0 1)
    (get 'ndefstruct 'zwei:definition-type-name) "Class"
    (get 'ndefstruct 'zwei:definition-function-spec-finder-template) '(0 1))
  )

;;; These changes let me dump instances of PCL metaclasses in files, and also arrange
;;; for the #S syntax to work for PCL instances.
;;; si:dump-object and si:get-defstruct-constructor-macro-name get "advised".
;;; Actually the advice is done by hand since it doesn't get compiled otherwise.

(defvar *old-dump-object*)
(defun patched-dump-object (object stream)
  (if (or (si:send si:*bin-dump-table* :get-hash object)
	  (not (and (%instancep object)
		    (class-standard-constructor (class-of object)))))
      (funcall *old-dump-object* object stream)
      ;; Code pratically copied from dump-instance.
      (let ((index (si:enter-table object stream t t)))
	(si:dump-form-to-eval
	  (cons (class-standard-constructor (class-of object))
		(iterate
		  ((slot in (all-slots object) by cddr)
		   (val in (cdr (all-slots object)) by cddr))
		  (collect (make-keyword slot))
		  (collect `',val)))
	  stream)
	(si:finish-enter-table object index))))

(unless (boundp '*old-dump-object*)
  (setf *old-dump-object* (symbol-function 'si:dump-object)
	(symbol-function 'si:dump-object) 'patched-dump-object))

(defvar *old-get-defstruct-constructor-macro-name*)
(defun patched-get-defstruct-constructor-macro-name (structure)
  (let ((class (class-named structure t)))
    (if class
	(class-standard-constructor class)
	(funcall *old-get-defstruct-constructor-macro-name* structure))))


(unless (boundp '*old-get-defstruct-constructor-macro-name*)
  (setf *old-get-defstruct-constructor-macro-name*
	   (symbol-function 'si:get-defstruct-constructor-macro-name)
	(symbol-function 'si:get-defstruct-constructor-macro-name)
	   'patched-get-defstruct-constructor-macro-name))

;;; There is a bug in the 6.1 beta version of si:xr-cl-#s-macro.  Of course since
;;; Bolics has chosen not to ship sources for this function its harder to fix than
;;; it should be.  This is a rewrite of that function, based on reading Steele and
;;; the disassembled code.
si:
(defun xr-cl-#s-macro (list-so-far stream)
  list-so-far
  (let ((list (read-recursive stream))
	constructor)
    (and (atom list)
	 (read-error stream "#S was followed by ~S, which is not a list" list))
    (cond ((setq constructor (get-defstruct-constructor-macro-name (car list)))
	   (loop for x on (cdr list) by 'cddr
		  do (rplaca x (intern (string (car x)) 'keyword)))
	   (apply constructor (cdr list)))
	  (t
	   (ferror "~S is either not the name of a structure or doesn't have a~%~
                    standard constructor macro.")))))


(fmakunbound 'lt::expand-subst-definition-internal)	;LT seems to have this bug.

;from >rel-6>sys2>comfile
;;; This is the normal function for looking at each form read from the file and calling
;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it.
;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time.  It is
;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...).
zl:compiler:
(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL) &AUX FUNCTION TEM)
  (DECLARE (SPECIAL FORM))
  (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))
	(*forcing* compile-time-too))
    (declare (special *forcing*))
    (LET ((ERROR-MESSAGE-HOOK
	    (CLOSURE '(FORM) #'(LAMBDA ()
				 (LET ((PRINLEVEL DBG:*ERROR-MESSAGE-PRINLEVEL*)
				       (PRINLENGTH DBG:*ERROR-MESSAGE-PRINLENGTH*))
				   (FORMAT T "~&While processing ~S" FORM))))))
      (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM)))
    (COND ((ATOM FORM))				;Ignore atoms at top-level
	  ((EQ (SETQ FUNCTION (CAR FORM)) 'QUOTE))	;and quoted constants e.g. 'COMPILE
	  ((EQ FUNCTION 'EVAL-WHEN)
	   (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM))
	   (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM))
				(AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM)))))
		 (LOAD-P (MEMQ 'LOAD (CADR FORM)))
		 (FORMS (CDDR FORM)))
	     (COND (LOAD-P
		    (DOLIST (FORM FORMS)
		      (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE))))
		   (COMPILE-P
		    (DOLIST (FORM FORMS)
		      (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL))))))
	  ((EQ FUNCTION 'PROGN)
	   (DOLIST (FORM (CDR FORM))
	     (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
	  ((EQ FUNCTION 'DEF)
	   (DOLIST (FORM (CDDR FORM))
	     (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)))
	  ((MEMQ FUNCTION '(MACRO SPECIAL UNSPECIAL))
	   (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T))
	  ((EQ FUNCTION 'DECLARE)
	   (DOLIST (FORM (CDR FORM))
	     (CHECK-DECLARATION-BUG FORM)
	     (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T)
		      ;; (DECLARE (SPECIAL ... has load-time action as well.
		      ;;